home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / GW AdaEd 1.4.2 / GWAdaDemos / NYUDemos / GENQSORT.ADA < prev    next >
Text File  |  1993-01-31  |  3KB  |  118 lines
  1. -- A generic sorting package, with a parallel quicksort algorithm: each
  2. -- half of the partitioned array is sorted by a separate task.
  3.  
  4. generic
  5.    type DATA is private;
  6.    type INDEX is (<>);
  7.    with function "<"(X,Y: DATA) return BOOLEAN is <> ;
  8. package SORTS is
  9.    type TABLE is array (INDEX range <>) of DATA;
  10.    procedure QUICKSORT (TAB: in out TABLE);
  11. end SORTS;
  12.  
  13.  
  14. package body SORTS is
  15.  
  16.    procedure QUICKSORT( TAB: in out TABLE ) is
  17.       
  18.       task type QSORT is
  19.          entry BOUNDS( L,R: in INDEX );
  20.       end QSORT;
  21.       
  22.       -- The name of the task cannot be used as  a type mark within the
  23.       -- task body. To allow recursive spawning, we make a subtype of it
  24.  
  25.       subtype SQSORT is QSORT; 
  26.  
  27.       type AQSORT is access QSORT;
  28.       TSORT:AQSORT;
  29.  
  30.       task body QSORT is
  31.          TRIGHT,TLEFT: AQSORT;
  32.          LEFT,RIGHT,IL,IR: INDEX;
  33.          MID,TEMP: DATA;
  34.       begin
  35.  
  36.          accept BOUNDS( L,R: in INDEX ) do
  37.         -- Acquire bounds of subarray to sort.
  38.             LEFT := L; RIGHT := R;
  39.          end BOUNDS;
  40.  
  41.          IL := LEFT; IR := RIGHT;
  42.  
  43.      -- Pick partitioning element (arbitrarily, in the middle).
  44.          MID := TAB( INDEX'VAL( (INDEX'POS(IL)+INDEX'POS(IR))/2) );
  45.  
  46.          loop                -- partitioning step.
  47.             while TAB(IL) < MID
  48.             loop
  49.                IL:=INDEX'SUCC(IL);
  50.             end loop;
  51.  
  52.             while MID < TAB(IR)
  53.             loop
  54.                IR:=INDEX'PRED(IR);
  55.             end loop;
  56.  
  57.             if IL <= IR then
  58.                TEMP := TAB(IL);
  59.                TAB(IL) := TAB(IR);
  60.                TAB(IR) := TEMP;
  61.                IL:=INDEX'SUCC(IL);
  62.                IR:=INDEX'PRED(IR);
  63.             end if;
  64.             exit when IL > IR;
  65.          end loop;
  66.  
  67.          if LEFT < IR then        -- spawn new task for left side.
  68.             TLEFT := new SQSORT;
  69.             TLEFT.BOUNDS(LEFT,IR);
  70.          end if;
  71.  
  72.          if IL < RIGHT then        -- ditto for right side.
  73.             TRIGHT := new SQSORT;
  74.             TRIGHT.BOUNDS(IL,RIGHT);
  75.          end if;
  76.       end QSORT;
  77.         
  78.    begin
  79.       TSORT := new QSORT;        -- Main task for whole array.
  80.       TSORT.BOUNDS( TAB'FIRST, TAB'LAST );
  81.    end QUICKSORT;
  82.  
  83. end SORTS;
  84.  
  85. with SORTS;
  86. with TEXT_IO;  use TEXT_IO;
  87.  
  88. procedure MAIN is
  89.  
  90.   package SORT_I is new SORTS( INTEGER,   INTEGER) ;
  91.   package SORT_C is new SORTS( CHARACTER, INTEGER) ;
  92.   use SORT_I, SORT_C ;
  93.  
  94.   package INT_IO is new INTEGER_IO(integer); use INT_IO;
  95.  
  96.   subtype VECT is SORT_I.TABLE(1..8);
  97.   subtype CHRS is SORT_C.TABLE(1..8);
  98.  
  99.   A: VECT := (-7, 14, 1, 92, 8,-6, 3, 2);
  100.   B: CHRS := "Alleluia" ;
  101.  
  102. begin
  103.    put_line("Sort integers") ;
  104.    QUICKSORT(A);
  105.    for I in A'RANGE loop
  106.      PUT (A(I));
  107.    end loop;
  108.    NEW_LINE;
  109.  
  110.    put_line("Sort characters") ;
  111.    QUICKSORT(B);
  112.    for I in B'RANGE loop
  113.      PUT (B(I));
  114.    end loop;
  115.    NEW_LINE;
  116.  
  117. end MAIN;
  118.